home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / System source / longMath < prev    next >
Text File  |  1993-02-21  |  7KB  |  310 lines
  1. \ Long arithmetic.    mrh  Aug 90.
  2.  
  3. \ Jun 92    32-bit 68000 code moved to main dic.  Removed / and /mod from here
  4. \    since main dic versions are now 32-bit.
  5. \ Sept 92    Revised to support the ANSI standard.
  6.  
  7. \ This file implements double-length (64 bit) addition and subtraction, 32*32->64 multiplication and 64/32->32 division, and versions of */ and */MOD which have a 64-bit intermediate result.
  8. \ This behavior is required by the ANSI standard, defined in terms of cells.  It may be overkill for Mops which has 32-bit cells, so we don't put it in the nucleus, but provide it here as an option.
  9.  
  10. :code S>D
  11.         loc
  12.         move    (a6),d0
  13.         bmi.s    mn                ; This is quicker than two EXT's
  14.         clr.l    -(a6)
  15.         rts
  16.  
  17. mn        moveq    #-1,d0
  18.         push.l    d0
  19. ;code
  20.  
  21. :code DNEG
  22.         neg    4(a6)
  23.         negx    (a6)
  24. ;code
  25.  
  26. :code D+
  27.         movem    (a6)+,d0-d2
  28.         add        d1,(a6)
  29.         addx    d0,d2
  30.         push    d2
  31. ;code
  32.  
  33. :code D-
  34.         movem    (a6)+,d0-d2
  35.         sub        d1,(a6)
  36.         subx    d0,d2
  37.         push    d2
  38. ;code
  39.  
  40. :code D<    loc
  41.         movem    (a6)+,d0-d2
  42.         cmp        d0,d2
  43.         blt.s    setTrue
  44.         bgt.s    setFalse
  45.         cmp        (a6),d1
  46.         bhi.s    setTrue
  47.  
  48. setFalse
  49.         clr        (a6)
  50.         rts
  51.  
  52. setTrue    moveq    #-1,d0
  53.         move    d0,(a6)
  54. ;code
  55.  
  56. :code D>
  57.         movem    (a6)+,d0-d2
  58.         cmp        d0,d2
  59.         bgt.s    setTrue
  60.         blt.s    setFalse
  61.         cmp        (a6),d1
  62.         blo.s    setTrue
  63.         bra.s    setFalse
  64. ;code
  65.  
  66. :code D=
  67.         movem    (a6)+,d0-d2
  68.         cmp    d0,d2
  69.         bne.s    setFalse
  70.         cmp    (a6),d1
  71.         bne.s    setFalse
  72.         bra.s    setTrue
  73. ;code
  74.  
  75.  
  76. \ The somewhat dreaded multiply routines
  77.  
  78. :code LONGMULT    ; Subroutine to do long unsigned multiply
  79.         loc
  80.         pop.l    d0
  81.         move.l    (a6),d1
  82.         clr.l    -(a6)
  83.         move.w    d1,d2
  84.         mulu    d0,d2
  85.         move.l    d2,4(a6)
  86.         move.l    d1,d2
  87.         swap    d2
  88.         mulu    d0,d2
  89.         add.l    d2,2(a6)
  90.         swap    d0
  91.         move.w    d1,d2
  92.         mulu    d0,d2
  93.         add.l    d2,2(a6)
  94.         bcc.s    mpy2
  95.         addq.w    #1,(a6)
  96. mpy2    move.l    d1,d2
  97.         swap    d2
  98.         mulu    d0,d2
  99.         add.l    d2,(a6)
  100. ;code
  101.  
  102.  
  103. :code UM*        ; Unsigned mixed multiply
  104.         loc
  105.         bra.s    p68k      ; NOP'd out if we're on an 020/030 or later
  106.  
  107.         pop.l    d1
  108.         dc.w    $4C16,$1400    ; mulu.l  (a6),d0:d1
  109.         move.l    d1,(a6)
  110.         push.l    d0
  111.         rts
  112.  
  113. p68k    tst.w    (a6)            ; If both high-order words are zero,
  114.         bne.s    dic[longMult]    ;  we can do a short multiply.
  115.         tst.w    4(a6)
  116.         bne.s    dic[longMult]
  117.         pop.l    d0                ; Yes, we can.
  118.         move.l    (a6),d1
  119.         mulu    d0,d1
  120.         move.l    d1,(a6)
  121.         clr.l    -(a6)
  122. ;code
  123.  
  124.  
  125. :code M*        ; Signed mixed multiply
  126.         loc
  127.         bra.s    p68k          ; NOP'd out if we're on an 020/030 or later
  128.  
  129.         pop.l    d1
  130.         dc.w    $4C16,$1C00    ; muls.l  (a6),d0:d1
  131.         move.l    d1,(a6)
  132.         push.l    d0
  133.         rts
  134.  
  135. p68k    tst.l    (a6)        ; If either operand is positive, the
  136.         bpl.s    dic[um*]    ; result will be identical to
  137.         tst.l    4(a6)        ; unsigned multiplication, so we
  138.         bpl.s    dic[um*]    ;  go straight there.
  139.         neg.l    (a6)        ; Both negative.  Negate them, then
  140.         neg.l    4(a6)        ; go to unsigned long mult routine.
  141.         bra        dic[longMult]
  142. ;code
  143.  
  144.  
  145. \ Division.
  146.  
  147. : DIV_OVERFLOW    24 ArithErr  ;
  148. : ZERO_DIV        25 ArithErr  ;
  149.  
  150.  
  151. :code  UM/MOD    ; Unsigned mixed division.  Code lifted
  152.                 ; from yours truly's PDP-11 implementation,
  153.                 ; which I prefer to the original Neon version.
  154.         loc
  155.         bra.s    ummod            ; NOP'd out if we're on an 020/030 or later
  156.  
  157.         movem.l    (a6)+,d0-d2        ; Divisor to D0, dividend to D1-2
  158.         dc.w    $4C40,$2401        ; divu.l  d0,d1:d2
  159.         push.l    d1                ; Push remainder
  160.         push.l    d2                ; Push quotient
  161.         rts
  162.  
  163. ummod    tst.l    (a6)
  164.         beq.s    dic[zero_div]    ; Check for zero divide
  165.         tst.l    4(a6)            ; Top 32 bits of dividend zero?
  166.         bne.s    longdiv
  167.         move.l    (a6)+,(a6)        ; Yes - NIP them and call U/MOD (faster)
  168.         jmp    dic[u/mod]
  169.  
  170. longdiv    pop.l    d2    ; D2 = divisor
  171.         pop.l    d0
  172.         move.l    (a6),d1    ; D0/1 = dividend
  173.         cmp.l    d2,d0
  174.         bhs.s    dic[div_overflow]
  175.         move.l    d3,-(a7)
  176.         moveq    #31,d3
  177.  
  178. loop    asl.l    #1,d1
  179.         roxl.l    #1,d0
  180.         bcs.s    dosub
  181.         cmp.l    d2,d0
  182.         blo.s    lptest
  183. dosub    sub.l    d2,d0
  184.         addq    #1,d1
  185. lptest    dbra    d3,loop
  186.  
  187.         move.l    (a7)+,d3
  188.         move.l    d0,(a6)            ; Push remainder
  189.         push.l    d1                ; and quotient
  190. ;code
  191.  
  192.  
  193. :code  M/MOD  ; ( d n -- rem quot )  Signed mixed division
  194.  
  195.         bra.s    p68k            ; NOP'd out if we're on an 020/030 or later
  196.  
  197.         movem.l    (a6)+,d0-d2        ; Divisor to D0, dividend to D1-2
  198.         dc.w    $4C40,$2C01        ; divs.l  d0,d1:d2
  199.         push.l    d1                ; Push remainder
  200.         push.l    d2                ; Push quotient
  201.         rts
  202.  
  203. p68k    movem.l    d3-d4,-(a7)        ; Save regs
  204.         tst.l    (a6)            ; We make everything
  205.         smi    d3                    ; positive then call um/mod.
  206.         bpl.s    mm1
  207.         neg.l    (a6)
  208. mm1        tst.l    4(a6)
  209.         smi    d4
  210.         bpl.s    mm2
  211.         neg.l    8(a6)
  212.         negx.l    4(a6)
  213.  
  214. mm2        bsr.s    ummod
  215.         tst.l    4(a6)
  216.         bmi    dic[div_overflow]
  217.         eor.b    d4,d3            ; Set sign of quotient
  218.         bpl.s    mm3
  219.         neg.l    (a6)
  220. mm3        tst.b    d4                ; Set sign of remainder - same as dividend,
  221.         bpl.s    rtn                ; which is different from original Neon.
  222.         neg.l    4(a6)            ; Yes, this was a bug!
  223. rtn        movem.l    (a7)+,d3-d4        ; Restore regs and return
  224. ;code
  225.  
  226.  
  227. : */MOD    >r  m*  r>  m/mod  ;
  228.  
  229. : */    */mod  nip  ;
  230.  
  231. : UMD/MOD  { dndL dndH dsr \ quotH -- rem quotL quotH }
  232.     dndL
  233.     dndH 0  dsr  um/mod  -> quotH
  234.     ( dndL rem1 ) dsr  um/mod  quotH  ;
  235.  
  236.  
  237. \ FM/MOD and SM/REM are the ANSI division words forcing floored and symmetric
  238. \ division respectively.  The 680x0 signed division is symmetric, so that
  239. \ is, naturally, the Mops default (defined by M/MOD).  For FM/MOD we have
  240. \ to do a little work.
  241.  
  242. : SM/REM    \ ( d n -- rem quot )
  243.     m/mod  ;
  244.  
  245. \ FM/MOD  ( d n -- mod quot )
  246. \ If the signs of the divisor and dividend are the same, the result is
  247. \ identical to SM/REM (i.e. M/MOD), as it is if the signs differ but
  248. \ the remainder from calling M/MOD is zero.  If the remainder is non-zero,
  249. \ we need to adjust by subtracting 1 from the quotient, and adding the
  250. \ divisor to the remainder.  This works whichever way around the signs are.
  251.  
  252. :code  FM/MOD
  253.         loc
  254.         move.l    (a6),d0
  255.         move.l    4(a6),d1
  256.         eor.l    d0,d1
  257.         bpl        dic[m/mod]        ; Signs same - call M/MOD and out.
  258.         move.l    (a6),-(a7)        ; Signs differ.  Save divisor
  259.         bsr        dic[m/mod]        ; Call M/MOD
  260.         move.l    (a7)+,d0        ; Recover divisor to D0
  261.         tst.l    4(a6)            ; Remainder zero?
  262.         beq.s    out                ; Yes - we're finished.
  263.         subq.l    #1,(a6)            ; No - do adjustment.
  264.         add.l    d0,4(a6)
  265. out
  266. ;code
  267.  
  268.  
  269. \ NumAccumulate ( ud1 digit -- ud2 ) is a vector called by >NUMBER.  It
  270. \ multiplies ud1 by BASE, then adds the digit.  In the nucleus we don't
  271. \ implement double-length arithmetic, so we ignore the hi cell of ud1,
  272. \ and put zero in the hi cell of ud2.  Here we implement a proper
  273. \ double-length version.
  274.  
  275. : (NumAcc)  { udL udH dig \ prod1H -- ud2 }
  276.         udL base um*  -> prod1H
  277.         udH base *  prod1H +
  278.         dig 0  d+  ;
  279.  
  280. ' (numAcc)  -> NumAccumulate
  281.  
  282.  
  283. \ Call initLongMath before using any LongMath words.  At present all it
  284. \ does is to test what processor we're running on, and patch the words to
  285. \ use the 020/030 long mult and div instructions if they exist.  This will
  286. \ improve the performance significantly.
  287.  
  288. : INITLONGMATH  { \ nop -- }
  289.     processor  2 <= ?EXIT        \ Out if 68000/68010
  290.     $ 4E71  -> nop
  291.     nop  ['] um*    w!
  292.     nop  ['] m*    w!
  293.     nop  ['] um/mod    w!
  294.     nop  ['] m/mod    w!
  295.     patches_done  ;
  296.     
  297. ' initLongMath  add: init_actions
  298.  
  299. endload
  300.  
  301. \ Comment out the endload for Neon compatibility.  We've used ANSI Forth
  302. \ word names, but these are redefined to their Neon equivalents below.
  303. \ I hope you don't find these various word names as confusing as I do.
  304.  
  305. : S->D    s>d  ;
  306. : U*    um*  ;
  307. : U/    um/mod  ;
  308. : M/    m/mod  ;
  309. : M/MOD    umd/mod  ;
  310.